home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / lib / dump.tcl < prev    next >
Encoding:
Text File  |  1997-10-23  |  11.7 KB  |  403 lines

  1. ##############################################################################
  2. # $Id: dump.tcl,v 1.13 1997/10/24 01:47:40 stewart Exp $
  3. #
  4. # dump.tcl - procedures to export widget information
  5. #
  6. # Copyright (C) 1996-1997 Stewart Allen
  7. #
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the terms of the GNU General Public License
  10. # as published by the Free Software Foundation; either version 2
  11. # of the License, or (at your option) any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful,
  14. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. # GNU General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program; if not, write to the Free Software
  20. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ##############################################################################
  23. #
  24.  
  25. proc vTcl:save_vars {} {
  26.     global vTcl
  27.     set output ""
  28.     set list $vTcl(vars)
  29.     vTcl:list add widget list
  30.     foreach i $list {
  31.         catch {
  32.             if [vTcl:valid_varname $i] {
  33.                 global $i
  34.                 append output "global $i; "
  35.                 if {[array exists $i] == 1} {
  36.                     append output "\n"
  37.                     set names [lsort [array names $i]]
  38.                     foreach j $names {
  39.                         set value "[subst $$i\($j\)]"
  40.                         if {$vTcl(pr,saveglob) == 1 || $i == "widget"} {
  41.                             append output "$vTcl(tab)set $i\($j\) \{$value\}\n"
  42.                         }
  43.                     }
  44.                 } else {
  45.                     if {$vTcl(pr,saveglob) == 1} {
  46.                         append output "set $i \{[subst $\{$i\}]\}"
  47.                     }
  48.                     append output "\n"
  49.                 }
  50.             }
  51.         }
  52.     }
  53.     return "$output"
  54. }
  55.  
  56. proc vTcl:save_procs {} {
  57.     global vTcl
  58.     set output ""
  59.     set list $vTcl(procs)
  60.     vTcl:list add Window list
  61.     foreach i $list {
  62.         if {[vTcl:ignore_procname_when_saving $i] == 0} {
  63.             set args ""
  64.             foreach j [info args $i] {
  65.                 if {[info default $i $j value]} {
  66.                     lappend args [list $j $value]
  67.                 } else {
  68.                     lappend args $j
  69.                 }
  70.             }
  71.             set body [string trim [info body $i]]
  72.             if {($body != "" || $i == "main") && $i != "init"} {
  73.                 append output "\nproc \{$i\} \{$args\} \{\n$body\n\}\n"
  74.             }
  75.         }
  76.     }
  77.     return $output
  78. }
  79.  
  80. proc vTcl:save_tree {target} {
  81.     global vTcl
  82.     set output ""
  83.     set vTcl(dumptops) ""
  84.     set vTcl(showtops) ""
  85.     set vTcl(var_update) "no"
  86.     set vTcl(num,index) 0
  87.     set tops ". $vTcl(tops)"
  88.     vTcl:status "Saving: collecting data"
  89.     set vTcl(num,total) [llength [vTcl:list_widget_tree $target]]
  90.     foreach i $tops {
  91.         append output [vTcl:dump_top $i]
  92.     }
  93.     append output "\n"
  94.     vTcl:status "Saving: collecting options"
  95.     foreach i $vTcl(showtops) {
  96.         append output "Window show $i\n"
  97.     }
  98.     set vTcl(var_update) "yes"
  99.     vTcl:statbar 0
  100.     vTcl:status "Saving: writing data"
  101.     return $output
  102. }
  103.  
  104. proc vTcl:valid_class {class} {
  105.     global vTcl
  106.     if {[lsearch $vTcl(classes) $class] >= 0} {
  107.         return 1
  108.     } else {
  109.         return 0
  110.     }
  111. }
  112.  
  113. proc vTcl:get_class {target {lower 0}} {
  114.     set class [winfo class $target]
  115.     if {![vTcl:valid_class $class]} {
  116.         set class Toplevel
  117.     }
  118.     if {$lower == 1} {
  119.         set class [vTcl:lower_first $class]
  120.     }
  121.     return $class
  122. }
  123.  
  124. proc vTcl:get_mgropts {opts} {
  125. #    if {[lindex $opts 0] == "-in"} {
  126. #        set opts [lrange $opts 2 end]
  127. #    }
  128.     set nopts ""
  129.     set spot a
  130.     foreach i $opts {
  131.         if {$spot == "a"} {
  132.             set o $i
  133.             set spot b
  134.         } else {
  135.             set v $i
  136.             switch -- $o {
  137.                 -ipadx -
  138.                 -ipady -
  139.                 -padx -
  140.                 -pady -
  141.                 -relx -
  142.                 -rely {
  143.                     if {$v != "" && $v != 0} {
  144.                         lappend nopts $o $v
  145.                     }
  146.                 }
  147.                 default {
  148.                     if {$v != ""} {
  149.                         lappend nopts $o $v
  150.                     }
  151.                 }
  152.             }
  153.             set spot a
  154.         }
  155.     }
  156.     return $nopts
  157. }
  158.  
  159. proc vTcl:get_opts {opts} {
  160.     set ret ""
  161.     foreach i $opts {
  162.         set o [lindex $i 0]
  163.         set v [lindex $i 4]
  164.         if {$o != "-class" && $v != [lindex $i 3]} {
  165.             lappend ret $o $v
  166.         }
  167.     }
  168.     return $ret
  169. }
  170.  
  171. proc vTcl:dump_widget_quick {target} {
  172.     global vTcl
  173.     vTcl:update_widget_info $target
  174.     set result "$target conf $vTcl(w,options)\n"
  175.     append result "$vTcl(w,manager) $target $vTcl(w,info)\n"
  176.     return $result
  177. }
  178.  
  179. proc vTcl:dump_widget_opt {target basename} {
  180.     global vTcl
  181.     set mgr [winfo manager $target]
  182. #    if {$mgr == ""} {return}
  183.     set result ""
  184.     set class [vTcl:get_class $target]
  185.     set opt [$target conf]
  186.     if {$target != "."} {
  187.         if {$class == "Menu" && [string first .# $target] >= 0} {
  188.             return
  189.         }
  190.         set result "$vTcl(tab)[vTcl:lower_first $class] $basename"
  191.         if {$mgr == "wm" && $class != "Menu"} {
  192.             append result " -class [winfo class $target]"
  193.         }
  194.         set p [vTcl:get_opts $opt]
  195.         if {$p != ""} {
  196.             append result " \\\n[vTcl:clean_pairs $p]\n"
  197.         } else {
  198.             append result "\n"
  199.         }
  200.     }
  201.     if {$mgr == "wm"} {
  202.         if {$class == "Menu"} {
  203.             append result [vTcl:dump_menu_widget $target $basename]
  204.         } else {
  205.             append result [vTcl:dump_top_widget $target $basename]
  206.         }
  207.     } elseif {$mgr == "menubar"} {
  208.         return ""
  209.     }
  210.     append result [vTcl:dump_widget_bind $target $basename]
  211.     return $result
  212. }
  213.  
  214. proc vTcl:dump_widget_geom {target basename} {
  215.     global vTcl
  216.     set mgr [winfo manager $target]
  217.     if {$mgr == ""} {return}
  218.     set class [winfo class $target]
  219.     set result ""
  220.     if {$mgr != "wm" && $mgr != "menubar" && $mgr != "tixGeometry" && $mgr != "tixForm"} {
  221.         set opts [$mgr info $target]
  222.         set result "$vTcl(tab)$mgr $basename \\\n"
  223.         append result "[vTcl:clean_pairs [vTcl:get_mgropts $opts]]\n"
  224.     }
  225.     set pre g
  226.     set gcolumn [lindex [grid size $target] 0]
  227.     set grow [lindex [grid size $target] 1]
  228.     foreach a {column row} {
  229.         foreach b {weight minsize} {
  230.             set num [subst $$pre$a]
  231.             for {set i 0} {$i < $num} {incr i} {
  232.                 if [catch {
  233.                     set x [expr round([grid ${a}conf $target $i -$b])]
  234.                 }] {set x 0}
  235.                 if $x {
  236.                     append result "$vTcl(tab)grid ${a}conf $basename $i -$b $x\n"
  237.                 }
  238.             }
  239.         }
  240.     }
  241.     return $result
  242. }
  243.  
  244. proc vTcl:dump_widget_bind {target basename} {
  245.     global vTcl
  246.     set result ""
  247.     if {[catch {bindtags $target \{$vTcl(bindtags,$target)\}}]} {
  248.         return ""
  249.     }
  250.     set bindlist [lsort [bind $target]]
  251.     foreach i $bindlist {
  252.         set command [bind $target $i]
  253.         if {"$vTcl(bind,ignore)" == "" || ![regexp "^($vTcl(bind,ignore))" [string trim $command]]} {
  254.             append result "$vTcl(tab)bind $basename $i \{\n"
  255.             append result "$vTcl(tab2)[string trim $command]\n    \}\n"
  256.         }
  257.     }
  258.     bindtags $target vTcl(b)
  259.     return $result
  260. }
  261.  
  262. proc vTcl:dump_menu_widget {target basename} {
  263. puts "dumping $target $basename"
  264.     global vTcl tk_version
  265.     set entries [$target index end]
  266.     if {$entries == "none"} {return}
  267.     set result ""
  268.     for {set index 0} {$index <= $entries} {incr index} {
  269.         set conf [$target entryconf $index]
  270.         set type [$target type $index]
  271.         switch $type {
  272.             tearoff {}
  273.             separator {
  274.                 append result "$vTcl(tab)$basename add separator\n"
  275.             }
  276.             default {
  277.                 set pairs [vTcl:conf_to_pairs $conf ""]
  278.                 append result "$vTcl(tab)$basename add $type \\\n"
  279.                 append result "[vTcl:clean_pairs $pairs]\n"
  280.             }
  281.         }
  282.     }
  283.     return $result
  284. }
  285.  
  286. proc vTcl:dump_top_widget {target basename} {
  287.     global vTcl
  288.     set result ""
  289.     foreach i $vTcl(attr,tops) {
  290.         if { $vTcl(w,wm,$i) != "" } {
  291.             switch $i {
  292.                 class {}
  293.                 title {
  294.                     append result "$vTcl(tab)wm $i $basename"
  295.                     append result " \"$vTcl(w,wm,$i)\"\n"
  296.                 }
  297.                 state {
  298.                     switch $vTcl(w,wm,state) {
  299.                         iconic {
  300.                             append result "$vTcl(tab)wm iconify $basename\n"
  301.                         }
  302.                         normal {
  303.                             append result "$vTcl(tab)wm deiconify $basename\n"
  304.                         }
  305.                         withdrawn {
  306.                             if {$target == "."} {
  307.                                 append result "$vTcl(tab)wm withdraw $basename\n"
  308.                             }
  309.                         }
  310.                     }
  311.                 }
  312.                 default {
  313.                     append result "$vTcl(tab)wm $i $basename $vTcl(w,wm,$i)\n"
  314.                 }
  315.             }
  316.         }
  317.     }
  318.     return $result
  319. }
  320.  
  321. # kc: dump all procs in the same manner, including support of default
  322. # arguments.
  323. # returns: definition of proc if it exists, empty string otherwise
  324. proc vTcl:maybe_dump_proc {i} {
  325.     global vTcl
  326.     if {[info procs $i] != ""} {
  327.         set args ""
  328.         foreach j [info args $i] {
  329.             if {[info default $i $j value]} {
  330.                 lappend args [list $j $value]
  331.             } else {
  332.                 lappend args $j
  333.             }
  334.         }
  335.         set body [string trim [info body $i]]
  336.         return "\nproc $i \{$args\} \{\n$vTcl(tab)$body\n\}\n"
  337.     }
  338.     return ""
  339. }
  340.  
  341.  
  342. proc vTcl:dump_top {target} {
  343.     global vTcl
  344.     set output ""
  345.     set proc_base $vTcl(winname)$target
  346.     foreach i "$vTcl(winname)(pre)$target $vTcl(winname)(post)$target" {
  347.         append output [vTcl:maybe_dump_proc $i]
  348.     }
  349.     if ![winfo exists $target] {
  350.         if {[info procs $proc_base] == ""} {
  351.             return ""
  352.         }
  353.         append output [vTcl:maybe_dump_proc $proc_base]
  354.         return $output
  355.     }
  356.     if {[winfo class $target] != "Toplevel" && $target != "."} {
  357.         return
  358.     }
  359.     vTcl:update_widget_info $target
  360.     append output "\nproc $vTcl(winname)$target \{base\} \{\n"
  361.     append output "$vTcl(tab)if {\$base == \"\"} {\n"
  362.     append output "$vTcl(tab2)set base $target\n$vTcl(tab)}\n"
  363.     if { $target != "." } {
  364.         append output "$vTcl(tab)if \{\[winfo exists \$base\]\} \{\n"
  365.         append output "$vTcl(tab2)wm deiconify \$base; return\n"
  366.         append output "$vTcl(tab)\}\n"
  367.     }
  368.     if {[wm state $target] == "normal" ||
  369.         [wm state $target] == "iconic" ||
  370.         $target == "."} {
  371.         lappend vTcl(showtops) $target
  372.     }
  373.     incr vTcl(num,index)
  374.     vTcl:statbar [expr ($vTcl(num,index) * 100) / $vTcl(num,total)]
  375.  
  376.     append output [vTcl:dump:widgets $target]
  377.  
  378.     append output "\}\n"
  379.     return $output
  380. }
  381.  
  382. proc vTcl:dump:widgets {target} {
  383.     global vTcl
  384.  
  385.     set output ""
  386.     set tree [vTcl:widget_tree $target]
  387.     append output $vTcl(head,proc,widgets)
  388.     foreach i $tree {
  389.         set basename [vTcl:base_name $i]
  390.         set class [vTcl:get_class $i]
  391.         append output [$vTcl($class,dump_opt) $i $basename]
  392.         incr vTcl(num,index)
  393.         vTcl:statbar [expr ($vTcl(num,index) * 100) / $vTcl(num,total)]
  394.     }
  395.     append output $vTcl(head,proc,geometry)
  396.     foreach i $tree {
  397.         set basename [vTcl:base_name $i]
  398.         append output [vTcl:dump_widget_geom $i $basename]
  399.     }
  400.     return $output
  401. }
  402.  
  403.